Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/splotch.zip/SPLOTCH.PAS

Pascal/Delphi Source File | 1991-09-29 | 6KB | 292 lines

program Splotch;


{***************************************************************************
                                | SPLOTCH.pas  by Bill Reamy |
                                +----------------------------+

   An example of cellular automata.
   note: unlike "Life" and many other examples, Splotch has changes that
         occur one at a time, instead of an entrie 'generation' at a time.

   This program is loosly based on "Vote", ( no I don't remember who wrote
   it, I just remember reading about it in a computer magazine).

***************************************************************************}


uses
  Graph, CRT;


var
  Dummy : char;

  X, Y,
  C, R  : integer;


type
  ColorValue = record
                 RValue, GValue, BValue : byte;
               end;


var
  VgaPalette  : array[0..255] of ColorValue;




{$F+}
function FakeDet : integer;
begin
  FakeDet := 0;
end;
{$F-}




procedure VgaSetAllPalette;
var
  Count : integer;

begin
  for Count := 0 to 255
    do begin
       Port[$03C8] := Count;
       Port[$03C9] := VgaPalette[Count].RValue and 63;
       Port[$03C9] := VgaPalette[Count].GValue and 63;
       Port[$03C9] := VgaPalette[Count].BValue and 63;
       end;

end;




procedure VgaSetPalette;
var
  Count : integer;

begin
  for Count := 1 to 255
    do begin
       Port[$03C8] := Count;
       Port[$03C9] := VgaPalette[Count].RValue and 63;
       Port[$03C9] := VgaPalette[Count].GValue and 63;
       Port[$03C9] := VgaPalette[Count].BValue and 63;
       end;

end;




procedure RGBPalette;
var C :integer;
begin
  for C := 0 to 63
    do begin
       VgaPalette[C].RValue := C;
       VgaPalette[C].GValue := C;
       VgaPalette[C].BValue := C;
       end;
  for C := 64 to 127
    do begin
       VgaPalette[C].RValue := C;
       VgaPalette[C].GValue := 0;
       VgaPalette[C].BValue := 0;
       end;
  for C := 128 to 191
    do begin
       VgaPalette[C].RValue := 0;
       VgaPalette[C].GValue := C;
       VgaPalette[C].BValue := 0;
       end;
  for C := 192 to 255
    do begin
       VgaPalette[C].RValue := 0;
       VgaPalette[C].GValue := 0;
       VgaPalette[C].BValue := C;
       end;
  VGASetAllPalette;
end;




procedure MultiPalette;
var C : integer;
begin
  for C := 0 to 31
    do begin VgaPalette[C].RValue := (c and 31)*2;
             VgaPalette[C].GValue := (c and 31)*2;       { Gray       }
             VgaPalette[C].BValue := (c and 31)*2;
       end;
  for C := 32 to 63
    do begin VgaPalette[c].RValue := (c and 31)*2;
             VgaPalette[c].GValue := 0;                   { Red        }
             VgaPalette[c].BValue := 0;
       end;
  for C := 64 to 95
    do begin VgaPalette[c].RValue := 0;
             VgaPalette[c].GValue := (c and 31)*2;       { Green      }
             VgaPalette[c].BValue := 0;
       end;
  for C := 96 to 127
    do begin VgaPalette[c].RValue := 0;
             VgaPalette[c].GValue := 0;                    { Blue       }
             VgaPalette[c].BValue := (c and 31)*2;
       end;
  for C := 128 to 159
    do begin VgaPalette[c].RValue := (c and 31)*2;
             VgaPalette[c].GValue := (c and 31)*2;        { Gold       }
             VgaPalette[c].BValue := 0;
       end;
  for C := 160 to 191
    do begin VgaPalette[c].RValue := (c and 31)*2;
             VgaPalette[c].GValue := 0;                    { Purple     }
             VgaPalette[c].BValue := (c and 31)*2;
       end;
  for C := 192 to 223
    do begin VgaPalette[c].RValue := 0;
             VgaPalette[c].GValue := (c and 31)*2;        { Cyan       }
             VgaPalette[c].BValue := (c and 31)*2;
       end;
  for C := 224 to 255
    do begin VgaPalette[c].RValue := ((c and 31)shr 2)*2;
             VgaPalette[c].GValue := ((c and 31)shr 1)*2;    { Steel Blue }
             VgaPalette[c].BValue := (c and 31)*2;
       end;
  VgaPalette[0].RValue := 0;
  VgaPalette[0].GValue := 0;
  VgaPalette[0].BValue := 0;
  VgaSetAllPalette;
end;




procedure GrayPalette;
var
  C : integer;
begin
  for C := 0 to 256
    do begin
       VgaPalette[C].RValue := C;
       VgaPalette[C].GValue := C;
       VgaPalette[C].BValue := C;
       end;
  VgaSetAllPalette;
end;




procedure RandPalette;
var
  C,R,G,B : integer;
begin
  R := Random(64);
  G := Random(64);
  B := Random(64);
  for C := 0 to 255
    do begin
       VgaPalette[C].RValue := R+C;
       VgaPalette[C].GValue := G+C*2;
       VgaPalette[C].BValue := B+C*3;
       end;
  VGASetAllPalette;
end;




procedure NextPalette;
var
  Count : integer;
  T1, T2, T3 : byte;
begin
  T1 := VgaPalette[1].RValue;
  T2 := VgaPalette[1].GValue;
  T3 := VgaPalette[1].BValue;
  for Count := 2 to 255 do
    VgaPalette[Count-1] := VgaPalette[Count];
  VgaPalette[255].RValue := T1;
  VgaPalette[255].GValue := T2;
  VgaPalette[255].BValue := T3;
  VgaSetPalette;
end;




procedure Init;
var
  Gd, Gm : integer;
begin
  DetectGraph( Gd, Gm );
  if Gd <> VGA
    then begin
         Writeln( 'Sorry, SPLOTCH requires VGA.' );
         HALT(1);
         end;
  if InstallUserDriver( 'Vga256', @FakeDet ) = grError
    then HALT(1);
  Gd := Detect;
  InitGraph( Gd, Gm, '' );
  if GraphResult <> GrOK
    then begin
         Writeln( 'Error in SPLOTCH.exe: Not Enough Free Memory!' );
         HALT(1);
         end;
  MultiPalette;
  Randomize;
end;




begin
  Init;

  for X := 0 to 319 do
    for Y := 0 to 199 do
      PutPixel( X, Y, Random(256) );

  while not KeyPressed
    do begin
       X := Random(320);
       Y := Random(200);
       C := GetPixel(X,Y);
       R := Random(3);
       if R = 0
         then Inc(X)
         else if R = 1
                then Dec(X);
       R := Random(3);
       if R = 0
         then Inc(Y)
         else if R = 1
                then Dec(Y);
       if X < 0
         then X := 319
         else if X > 319
                then X := 0;

       if Y < 0
         then Y := 199
         else if Y > 199
                then Y := 0;

       PutPixel( X,Y, (C + GetPixel(X,Y)) div 2 );
       if (Mem[$0040:$0017] and $10) > 0
         then NextPalette;
       end;

  Dummy := ReadKey;
  CloseGraph;
end.